home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0187.ZIP / BLACKBOX.PAS < prev    next >
Pascal/Delphi Source File  |  1985-01-20  |  8KB  |  363 lines

  1. (*
  2.  * blackbox
  3.  * try to determine the location of n balls in a black box
  4.  *)
  5.  
  6. program blackbox(input, output);
  7.  
  8. const
  9.    side     =  8;     (* there are 8 squares to a side *)
  10.    siden1   =  9;     (* the length of one side plus one *)
  11.    maxstart = 32;     (* maximum possible location for ray *)
  12.    absorbed =  0;     (* what track returns when ray absorbed *)
  13.    boxsize  = 64;     (* size of the box *)
  14.  
  15. type
  16.    course   = (up,down,left,right);   (* possible directions for rays *)
  17.    lines    = array[0..siden1] of boolean;  (* possible locations in the box *)
  18.    location = 0..boxsize;                   (* 0 is for absorption *)
  19.  
  20. var
  21.    box       : array[0..siden1] of lines;  (* the black box *)
  22.    direction : course;                     (* the ray's current direction *)
  23.    startray  : 1..maxstart;                (* the ray's starting location *)
  24.    numballs  : integer;                    (* the number of balls *)
  25.  
  26. (*
  27.  * track
  28.  * recursive function that follows a ray's course through the box
  29.  *)
  30.  
  31. function track(place:location):location;
  32.  
  33. var
  34.    rownum : 1..side;
  35.    colnum : 1..side;
  36.  
  37. (*
  38.  * onside
  39.  * tests to see if there is a ball on either side of a ray
  40.  *)
  41.  
  42. function onside:boolean;
  43.  
  44. begin
  45.    if (direction = right) or (direction = left) then
  46.       onside := box[rownum-1][colnum] or box[rownum+1][colnum]
  47.    else
  48.       onside := box[rownum][colnum-1] or box[rownum][colnum+1]
  49. end;
  50.  
  51. (*
  52.  * edge
  53.  * tests if a ray has reached the end of the box
  54.  *)
  55.  
  56. function edge:boolean;
  57.  
  58. begin
  59.    case direction of
  60.       left : edge := ( (place - 1) mod side ) = 0;
  61.       right: edge := ( (place - 1) mod side ) = side - 1;
  62.       up   : edge := ( (place - 1) div side ) = 0;
  63.       down : edge := ( (place - 1) div side ) = side - 1
  64.    end
  65. end;
  66.  
  67. (*
  68.  * diagup
  69.  * tells me if there is a ball on the upward diagonal
  70.  *)
  71.  
  72. function diagup:boolean;
  73.  
  74. begin
  75.    case direction of
  76.       left : diagup := box[rownum-1][colnum-1];
  77.       right: diagup := box[rownum-1][colnum+1];
  78.       up   : diagup := box[rownum-1][colnum-1];
  79.       down : diagup := box[rownum+1][colnum-1]
  80.    end
  81. end;
  82.  
  83. (*
  84.  * diagdown
  85.  * tells me if there is a ball on the diagonal downward
  86.  *)
  87.  
  88. function diagdown:boolean;
  89.  
  90. begin
  91.    case direction of
  92.       left : diagdown := box[rownum+1][colnum-1];
  93.       right: diagdown := box[rownum+1][colnum+1];
  94.       up   : diagdown := box[rownum-1][colnum+1];
  95.       down : diagdown := box[rownum+1][colnum+1]
  96.    end
  97. end;
  98.  
  99. (*
  100.  * change
  101.  * moves the ray one square in the current direction
  102.  *)
  103.  
  104. procedure change(var num:location);
  105.  
  106. begin
  107.    (* if we are on an edge, then don't move *)
  108.    if not edge then
  109.       case direction of
  110.          left : num := num - 1;
  111.          right: num := num + 1;
  112.          up   : num := num - side;
  113.          down : num := num + side
  114.       end
  115. end;
  116.  
  117. (*
  118.  * track
  119.  *)
  120.  
  121. begin
  122.    rownum := (place - 1) div side + 1;
  123.    colnum := (place - 1) mod side + 1;
  124.  
  125.    if box[rownum][colnum] then
  126.       track := absorbed
  127.    else
  128.    begin
  129.       if onside then
  130.       begin
  131.          case direction of
  132.             left : direction := right;
  133.             right: direction := left;
  134.             up   : direction := down;
  135.             down : direction := up
  136.          end;
  137.          track := place
  138.       end
  139.       else
  140.       begin
  141.          if diagup and diagdown then
  142.          begin
  143.             case direction of
  144.                left : direction := right;
  145.                right: direction := left;
  146.                up   : direction := down;
  147.                down : direction := up
  148.             end;
  149.             change(place);
  150.             track := track(place)
  151.          end
  152.          else
  153.          begin
  154.             if diagup then
  155.             begin
  156.                case direction of
  157.                   left, right : direction := down;
  158.                   up,down     : direction := right
  159.                end;
  160.                change(place);
  161.                track := track(place)
  162.             end
  163.             else
  164.             if diagdown then
  165.             begin
  166.                case direction of
  167.                   left,right : direction := up;
  168.                   up,down    : direction := left
  169.                end;
  170.                change(place);
  171.                track := track(place)
  172.             end
  173.             else
  174.             if not edge then
  175.             begin
  176.                change(place);
  177.                track := track(place)
  178.             end
  179.             else
  180.                track := place
  181.          end
  182.       end
  183.    end
  184. end;
  185.  
  186. (*
  187.  * clearballs
  188.  * removes all the balls from the box
  189.  *)
  190.  
  191. procedure clearballs;
  192.  
  193. var
  194.    i,j : 0..siden1;
  195.  
  196. begin
  197.    for i := 0 to siden1 do
  198.       for j := 0 to siden1 do
  199.          box[i][j] := false
  200. end;
  201.  
  202. (*
  203.  * placeballs
  204.  * asks the user for the number of balls to place in the box, then
  205.  * randomly places the balls in the box
  206.  *)
  207.  
  208. procedure placeballs;
  209.  
  210. var
  211.    i,j    : 0..siden1;
  212.    placed : integer;
  213.  
  214. begin
  215.    randomize;
  216.    clearballs;
  217.  
  218.    writeln;
  219.    write('How many balls? ');
  220.    readln(numballs);
  221.    randomize;
  222.    placed := 0;
  223.    while placed < numballs do
  224.    begin
  225.       i := 1 + random(side);
  226.       j := 1 + random(side);
  227.       if not box[i][j] then
  228.       begin
  229.          box[i][j] := true;
  230.          placed := placed + 1
  231.       end
  232.    end
  233. end;
  234.  
  235. (*
  236.  * getray
  237.  * sits in a loop getting numbers from the user, and using them to determine
  238.  * where to fire a ray. if the number is 0, then the user is readu to guess
  239.  * where the balls are located.
  240.  *)
  241.  
  242. procedure getray;
  243.  
  244. var
  245.    raynum : integer;
  246.    outat  : location;
  247.  
  248. (*
  249.  * raytobox
  250.  * converts a user number into the equivalent location in the box
  251.  *)
  252.  
  253. procedure raytobox(var num : integer);
  254.  
  255. begin
  256.    if num <> 0 then
  257.    begin
  258.       if num <= side then
  259.       begin
  260.          direction := right;
  261.          num := (num-1)*side + 1
  262.       end
  263.       else
  264.       if num <= (side + side) then
  265.       begin
  266.          direction := up;
  267.          num := sqr(side) - ((2*side)-num)
  268.       end
  269.       else
  270.       if num <= (3 * side) then
  271.       begin
  272.          direction := left;
  273.          num := (3 * side - num + 1) * side
  274.       end
  275.       else
  276.       begin
  277.          direction := down;
  278.          num := (4 * side - num + 1)
  279.       end
  280.    end
  281. end;
  282.  
  283. (*
  284.  * boxtoray
  285.  * returns the ray location of an edge
  286.  *)
  287.  
  288. function boxtoray(place:location):location;
  289.  
  290. begin
  291.    case direction of
  292.       right : boxtoray := place div side + 17;
  293.       left  : boxtoray := (place + (side-1)) div side;
  294.       up    : boxtoray := 33 - place;
  295.       down  : boxtoray := place - 48
  296.    end
  297. end;
  298.  
  299. begin
  300.    repeat
  301.       write('Where should I shoot now? ');
  302.       readln(raynum);
  303.       while not (raynum in [0..maxstart]) do
  304.       begin
  305.          writeln('Sorry, but only numbers between 0 and ',maxstart);
  306.          write('Start where? ');
  307.          readln(raynum)
  308.       end;
  309.       if raynum <> 0 then
  310.       begin
  311.          write('in at ',raynum:2,' ');
  312.          outat := 0;
  313.          raytobox(raynum);
  314.          outat := track(raynum);
  315.          if outat = 0 then
  316.             writeln('Absorbed')
  317.          else
  318.             writeln('It came out at ',boxtoray(outat))
  319.       end
  320.    until raynum = 0
  321. end;
  322.  
  323. (*
  324.  * printballs
  325.  * prints out the balls
  326.  *)
  327.  
  328. procedure printballs;
  329.  
  330. var
  331.  
  332.    i,j : 1..side;
  333.  
  334. begin
  335.    writeln('  32 31 30 29 28 27 26 25');
  336.    writeln('  -------------------------');
  337.    for i := 1 to side do
  338.    begin
  339.       write(i:2,'(');
  340.       for j := 1 to side do
  341.          if box[i][j] then
  342.             write('*  ')
  343.          else
  344.             write('.  ');
  345.       writeln(')',25-i)
  346.    end;
  347.    writeln('  -------------------------');
  348.    writeln('  9  10 11 12 13 14 15 16')
  349. end;
  350.  
  351. begin
  352.    clearballs;
  353.    printballs;
  354.    placeballs;
  355.    getray;
  356.    printballs;
  357.  
  358. end.
  359.  
  360.  
  361.  
  362.  
  363.